home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
cmpnew
/
cmplam.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
29KB
|
838 lines
;;; CMPLAM Lambda expression.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
;;; During Pass1, a lambda-list
;;;
;;; ( { var }*
;;; [ &optional { var | ( var [ initform [ svar ] ] ) }* ]
;;; [ &rest var ]
;;; [ &key { var | ( { var | ( kwd var ) } [initform [ svar ]])}*
;;; [&allow-other-keys]]
;;; [ &aux {var | (var [initform])}*]
;;; )
;;;
;;; is transformed into
;;;
;;; ( ( { var }* ) ; required
;;; ( { (var initform svar) }* ) ; optional
;;; { var | nil } ; rest
;;; key-flag
;;; ( { ( kwd-vv-index var initform svar) }* ) ; key
;;; allow-other-keys-flag
;;; )
;;;
;;; where
;;; svar: nil ; means svar is not supplied
;;; | var
;;;
;;; &aux parameters will be embedded into LET*.
;;;
;;; c1lambda-expr receives
;;; ( lambda-list { doc | decl }* . body )
;;; and returns
;;; ( lambda info-object lambda-list' doc body' )
;;;
;;; Doc is NIL if no doc string is supplied.
;;; Body' is body possibly surrounded by a LET* (if &aux parameters are
;;; supplied) and an implicit block.
(defmacro ck-spec (condition)
`(unless ,condition
(cmperr "The parameter specification ~s is illegal." spec)))
(defmacro ck-vl (condition)
`(unless ,condition
(cmperr "The lambda list ~s is illegal." vl)))
(defun c1lambda-expr (lambda-expr
&optional (block-name nil block-it)
&aux (requireds nil) (optionals nil) (rest nil)
(keywords nil) (key-flag nil)
(allow-other-keys nil) (aux-vars nil)
(aux-inits nil) doc vl spec body ss is ts
other-decls vnames
(*vars* *vars*)
(info (make-info))
(aux-info nil)
)
(cmpck (endp lambda-expr)
"The lambda expression ~s is illegal." (cons 'lambda lambda-expr))
(multiple-value-setq (body ss ts is other-decls doc)
(c1body (cdr lambda-expr) t))
(when block-it (setq body (list (cons 'block (cons block-name body)))))
(c1add-globals ss)
(setq vl (car lambda-expr))
(block parse
(tagbody
Lreq
(when (null vl) (return-from parse))
(ck-vl (consp vl))
(case (setq spec (pop vl))
(&optional (go Lopt))
(&rest (go Lrest))
(&key (go Lkey))
(&aux (go Laux)))
(let ((v (c1make-var spec ss is ts)))
(push spec vnames)
(push v *vars*)
(push v requireds))
(go Lreq)
Lopt
(when (null vl) (return-from parse))
(ck-vl (consp vl))
(case (setq spec (pop vl))
(&rest (go Lrest))
(&key (go Lkey))
(&aux (go Laux)))
(cond ((not (consp spec))
(let ((v (c1make-var spec ss is ts)))
(push spec vnames)
(push (list v (default-init (var-type v)) nil) optionals)
(push v *vars*)))
((not (consp (cdr spec)))
(ck-spec (null (cdr spec)))
(let ((v (c1make-var (car spec) ss is ts)))
(push (car spec) vnames)
(push (list v (default-init (var-type v)) nil) optionals)
(push v *vars*)))
((not (consp (cddr spec)))
(ck-spec (null (cddr spec)))
(let ((init (c1expr* (cadr spec) info))
(v (c1make-var (car spec) ss is ts)))
(push (car spec) vnames)
(push
(list v (and-form-type (var-type v) init (cadr spec)) nil)
optionals)
(push v *vars*)))
(t
(ck-spec (null (cdddr spec)))
(let ((init (c1expr* (cadr spec) info))
(v (c1make-var (car spec) ss is ts))
(sv (c1make-var (caddr spec) ss is ts))
)
(push (car spec) vnames)
(push (caddr spec) vnames)
(push
(list v (and-form-type (var-type v) init (cadr spec)) sv)
optionals)
(push v *vars*)
(push sv *vars*))))
(go Lopt)
Lrest
(ck-vl (consp vl))
(push (car vl) vnames)
(setq rest (c1make-var (pop vl) ss is ts))
(push rest *vars*)
(when (null vl) (return-from parse))
(ck-vl (consp vl))
(case (setq spec (pop vl))
(&key (go Lkey))
(&aux (go Laux)))
(cmperr "Either &key or &aux is missing before ~s." spec)
Lkey
(setq key-flag t)
(when (null vl) (return-from parse))
(ck-vl (consp vl))
(case (setq spec (pop vl))
(&aux (go Laux))
(&allow-other-keys (setq allow-other-keys t)
(when (null vl) (return-from parse))
(ck-vl (consp vl))
(case (setq spec (pop vl))
(&aux (go Laux)))
(cmperr "&aux is missing before ~s." spec)))
(when (not (consp spec)) (setq spec (list spec)))
(cond ((consp (car spec))
(ck-spec (and (keywordp (caar spec))
(consp (cdar spec))
(null (cddar spec))))
(setq spec (cons (caar spec) (cons (cadar spec) (cdr spec)))))
(t
(ck-spec (symbolp (car spec)))
(setq spec (cons (intern (string (car spec)) 'keyword)
(cons (car spec) (cdr spec))))))
(cond ((not (consp (cddr spec)))
(ck-spec (null (cddr spec)))
(let ((v (c1make-var (cadr spec) ss is ts)))
(push (cadr spec) vnames)
(push
(list (car spec) v (default-init (var-type v))
(make-var :kind 'DUMMY))
keywords)
(push v *vars*)))
((not (consp (cdddr spec)))
(ck-spec (null (cdddr spec)))
(let ((init (c1expr* (caddr spec) info))
(v (c1make-var (cadr spec) ss is ts)))
(push (cadr spec) vnames)
(push (list (car spec) v
(and-form-type (var-type v) init (caddr spec))
(make-var :kind 'DUMMY))
keywords)
(push v *vars*)))
(t
(ck-spec (null (cddddr spec)))
(let ((init (c1expr* (caddr spec) info))
(v (c1make-var (cadr spec) ss is ts))
(sv (c1make-var (cadddr spec) ss is ts)))
(push (cadr spec) vnames)
(push (cadddr spec) vnames)
(push (list (car spec) v
(and-form-type (var-type v) init (caddr spec))
sv)
keywords)
(push v *vars*)
(push sv *vars*))))
(go Lkey)
Laux
(setq aux-info (make-info))
Laux1
(when (null vl) (add-info info aux-info) (return-from parse))
(ck-vl (consp vl))
(setq spec (pop vl))
(cond ((consp spec)
(cond ((not (consp (cdr spec)))
(ck-spec (null (cdr spec)))
(let ((v (c1make-var (car spec) ss is ts)))
(push (car spec) vnames)
(push (default-init (var-type v)) aux-inits)
(push v aux-vars)
(push v *vars*)))
(t
(ck-spec (null (cddr spec)))
(let ((init (c1expr* (cadr spec) aux-info))
(v (c1make-var (car spec) ss is ts)))
(push (car spec) vnames)
(push (and-form-type (var-type v) init (cadr spec))
aux-inits)
(push v aux-vars)
(push v *vars*)))))
(t
(let ((v (c1make-var spec ss is ts)))
(push spec vnames)
(push (default-init (var-type v)) aux-inits)
(push v aux-vars)
(push v *vars*))))
(go Laux1)
)
)
(setq requireds (reverse requireds)
optionals (reverse optionals)
keywords (reverse keywords)
aux-vars (reverse aux-vars)
aux-inits (reverse aux-inits))
(check-vdecl vnames ts is)
(setq body (c1decl-body other-decls body))
(add-info info (cadr body))
(dolist** (var requireds) (check-vref var))
(dolist** (opt optionals)
(check-vref (car opt))
(when (caddr opt) (check-vref (caddr opt))))
(when rest (check-vref rest))
(dolist** (kwd keywords)
(check-vref (cadr kwd))
(when (cadddr kwd) (check-vref (cadddr kwd))))
(dolist** (var aux-vars) (check-vref var))
(when aux-vars
(add-info aux-info (cadr body))
(setq body (list 'let* aux-info aux-vars aux-inits body)))
(list 'lambda
info
(list requireds optionals rest key-flag keywords allow-other-keys)
doc
body)
)
(defun the-parameter (name)
(cmpck (not (symbolp name)) "The parameter ~s is not a symbol." name)
(cmpck (constantp name) "The constant ~s is being bound." name)
name
)
(defun c2lambda-expr (lambda-list body &optional (fname nil s-fname))
(let ((*tail-recursion-info* ;;; Tail recursion possible if
(if (and *do-tail-recursion*
s-fname ;;; named function,
(dolist* (var (car lambda-list) t)
(when (var-ref-ccb var) (return nil)))
;;; no required is closed in a closure,
(null (cadr lambda-list)) ;;; no optionals,
(null (caddr lambda-list)) ;;; no rest parameter, and
(not (cadddr lambda-list))) ;;; no keywords.
(cons fname (car lambda-list))
nil)))
(if (cadddr lambda-list) ;;; key-flag
(c2lambda-expr-with-key lambda-list body)
(c2lambda-expr-without-key lambda-list body)))
)
(defun c2lambda-expr-without-key
(lambda-list body
&aux (requireds (car lambda-list))
(optionals (cadr lambda-list))
(rest (caddr lambda-list))
(labels nil)
(*unwind-exit* *unwind-exit*)
(*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)
(block-p nil)
)
(declare (object requireds optionals rest))
;;; Allocate immediate-type parameters.
(flet ((do-decl (var)
(let ((kind (c2var-kind var)))
(declare (object kind))
(when kind
(let ((cvar (next-cvar)))
(setf (var-kind var) kind)
(setf (var-loc var) cvar)
(wt-nl)
(unless block-p (wt "{") (setq block-p t))
(wt (rep-type kind) "V" cvar ";"))))))
(dolist** (v requireds) (do-decl v))
(dolist** (opt optionals)
(do-decl (car opt))
(when (caddr opt) (do-decl (caddr opt))))
(when rest (do-decl rest))
)
;;; check arguments
(when (or *safe-compile* *compiler-check-args*)
(cond ((or rest optionals)
(when requireds
(wt-nl "if(vs_top-vs_base<" (length requireds)
") too_few_arguments();"))
(unless rest
(wt-nl "if(vs_top-vs_base>"
(+ (length requireds) (length optionals))
") too_many_arguments();")))
(t (wt-nl "check_arg(" (length requireds) ");"))))
;;; Allocate the parameters.
(dolist** (var requireds) (setf (var-ref var) (vs-push)))
(dolist** (opt optionals) (setf (var-ref (car opt)) (vs-push)))
(when rest (setf (var-ref rest) (vs-push)))
(dolist** (opt optionals)
(when (caddr opt) (setf (var-ref (caddr opt)) (vs-push))))
;;; Bind required parameters.
(dolist** (var requireds) (c2bind var))
;;; Bind optional parameters as long as there remain arguments.
;;; The compile-time binding is discarded because they are bound again.
(when (and (or optionals rest) (not (null requireds)))
(wt-nl "vs_base=vs_base+" (length requireds) ";"))
(cond (optionals
(let ((*clink* *clink*)
(*unwind-exit* *unwind-exit*)
(*ccb-vs* *ccb-vs*))
(do ((opts optionals (cdr opts)))
((endp opts))
(declare (object opts))
(push (next-label) labels)
(wt-nl "if(vs_base>=vs_top){")
(reset-top)
(wt-go (car labels)) (wt "}")
(c2bind (caar opts))
(when (caddar opts) (c2bind-loc (caddar opts) t))
(when (or (cdr opts) rest) (wt-nl "vs_base++;"))
)
(when rest
(wt-nl "vs_top[0]=Cnil;")
(wt-nl "{object *p=vs_top;")
(wt-nl " for(;p>vs_base;p--)p[-1]=MMcons(p[-1],p[0]);}")
(c2bind rest))
)
(wt-nl) (reset-top)
(let ((label (next-label)))
(wt-nl) (wt-go label)
(setq labels (reverse labels))
;;; Bind unspecified optional parameters.
(dolist** (opt optionals)
(wt-label (car labels))
(pop labels)
(c2bind-init (car opt) (cadr opt))
(when (caddr opt) (c2bind-loc (caddr opt) nil)))
(when rest (c2bind-loc rest nil))
(wt-label label)))
(rest
(wt-nl "vs_top[0]=Cnil;")
(wt-nl "{object *p=vs_top;")
(wt-nl " for(;p>vs_base;p--)p[-1]=MMcons(p[-1],p[0]);}")
(c2bind rest)
(wt-nl)
(reset-top))
(t
(wt-nl)
(reset-top)))
(when *tail-recursion-info*
(push 'tail-recursion-mark *unwind-exit*) (wt-nl1 "TTL:;"))
;;; Now the parameters are ready!
(c2expr body)
(when block-p (wt-nl "}"))
)
(defun c2lambda-expr-with-key
(lambda-list body
&aux (requireds (nth 0 lambda-list))
(optionals (nth 1 lambda-list))
(rest (nth 2 lambda-list))
(keywords (nth 4 lambda-list))
(allow-other-keys (nth 5 lambda-list))
(labels nil)
(*unwind-exit* *unwind-exit*)
(*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*)
(block-p nil)
)
(declare
(object requireds optionals rest keywords allow-other-keys))
;;; Allocate immediate-type parameters.
(flet ((do-decl (var)
(let ((kind (c2var-kind var)))
(declare (object kind))
(when kind
(let ((cvar (next-cvar)))
(setf (var-kind var) kind)
(setf (var-loc var) cvar)
(wt-nl)
(unless block-p (wt "{") (setq block-p t))
(wt (rep-type kind) "V" cvar ";"))))))
(dolist** (v requireds) (do-decl v))
(dolist** (opt optionals)
(do-decl (car opt))
(when (caddr opt) (do-decl (caddr opt))))
(when rest (do-decl rest))
(dolist** (kwd keywords)
(do-decl (cadr kwd))
(when (cadddr kwd) (do-decl (cadddr kwd))))
)
;;; Check arguments.
(when (and (or *safe-compile* *compiler-check-args*) requireds)
(when requireds
(wt-nl "if(vs_top-vs_base<" (length requireds)
") too_few_arguments();")))
;;; Allocate the parameters.
(dolist** (var requireds) (setf (var-ref var) (vs-push)))
(dolist** (opt optionals)
(setf (var-ref (car opt)) (vs-push)))
(when rest (setf (var-ref rest) (vs-push)))
(dolist** (kwd keywords)
(setf (var-ref (cadr kwd)) (vs-push)))
(dolist** (kwd keywords)
(setf (var-ref (cadddr kwd)) (vs-push)))
(dolist** (opt optionals)
(when (caddr opt) (setf (var-ref (caddr opt)) (vs-push))))
;;; Assign rest and keyword parameters first.
;;; parse_key does not change vs_base and vs_top.
(wt-nl "parse_key(vs_base")
(when (or requireds optionals)
(wt "+" (+ (length requireds) (length optionals))))
(if rest (wt ",TRUE,") (wt ",FALSE,"))
(if allow-other-keys (wt "TRUE,") (wt "FALSE,"))
(wt (length keywords))
(dolist** (kwd keywords) (wt ",VV[" (add-symbol (car kwd)) "]"))
(wt ");")
;;; Bind required parameters.
(dolist** (var requireds) (c2bind var))
;;; Bind optional parameters as long as there remain arguments.
;;; The compile-time binding is discarded because they are bound again.
(when optionals
(when requireds (wt-nl "vs_base += " (length requireds) ";"))
(let ((*clink* *clink*)
(*unwind-exit* *unwind-exit*)
(*ccb-vs* *ccb-vs*))
(do ((opts optionals (cdr opts)))
((endp opts))
(declare (object opts))
(push (next-label) labels)
(wt-nl "if(vs_base>=vs_top){vs_top=sup;")
(wt-go (car labels)) (wt "}")
(c2bind (caar opts))
(when (caddar opts) (c2bind-loc (caddar opts) t))
(when (cdr opts) (wt-nl "vs_base++;"))))
(setq labels (reverse labels))
)
(wt-nl "vs_top=sup;")
(when optionals
(let ((label (next-label)))
(wt-go label)
;;; Bind unspecified optional parameters.
(dolist** (opt optionals)
(wt-label (car labels))
(pop labels)
(c2bind-init (car opt) (cadr opt))
(when (caddr opt) (c2bind-loc (caddr opt) nil)))
(wt-label label)
))
(when rest (c2bind rest))
;;; Bind keywords.
(dolist** (kwd keywords)
(cond ((and (eq (caaddr kwd) 'LOCATION) (null (caddr (caddr kwd))))
;;; Cnil has been set if keyword parameter is not supplied.
(c2bind (cadr kwd)))
(t
(wt-nl "if(") (wt-vs (var-ref (cadddr kwd))) (wt "==Cnil){")
(let ((*clink* *clink*)
(*unwind-exit* *unwind-exit*)
(*ccb-vs* *ccb-vs*))
(c2bind-init (cadr kwd) (caddr kwd)))
(wt-nl "}else{")
(c2bind (cadr kwd))
(wt "}")))
(unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind (cadddr kwd))))
;;; Now the parameters are ready, after all!
(c2expr body)
(when block-p (wt-nl "}"))
)
(defun need-to-set-vs-pointers (lambda-list)
;;; On entry to in-line lambda expression,
;;; vs_base and vs_top must be set iff,
(or *safe-compile*
*compiler-check-args*
(nth 1 lambda-list) ;;; optional,
(nth 2 lambda-list) ;;; rest, or
(nth 3 lambda-list) ;;; key-flag.
))
;;; The DEFMACRO compiler.
;;; valid lambda-list to DEFMACRO is:
;;;
;;; ( [ &whole sym ]
;;; [ &environment sym ]
;;; { v }*
;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ]
;;; { [ { &rest | &body } v ]
;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }*
;;; [ &allow-other-keys ]]
;;; [ &aux { sym | ( v [ init ] ) }* ]
;;; | . sym }
;;; )
;;;
;;; where v is short for { defmacro-lambda-list | sym }.
;;; Defamcro-lambda-list is defined as:
;;;
;;; ( { v }*
;;; [ &optional { sym | ( v [ init [ v ] ] ) }* ]
;;; { [ { &rest | &body } v ]
;;; [ &key { sym | ( { sym | ( key v ) } [ init [ v ]] ) }*
;;; [ &allow-other-keys ]]
;;; [ &aux { sym | ( v [ init ] ) }* ]
;;; | . sym }
;;; )
(defvar *vnames*)
(defvar *dm-info*)
(defvar *dm-vars*)
(defun c1dm (macro-name vl body
&aux (*vs* *vs*) (whole nil) (env nil)
(*vnames* nil) (*dm-info* (make-info)) (*dm-vars* nil)
doc ss is ts other-decls ppn)
(multiple-value-setq (body ss ts is other-decls doc) (c1body body t))
(setq body (list (list* 'block macro-name body)))
(c1add-globals ss)
(when (and (listp vl) (eq (car vl) '&whole))
(push (cadr vl) *vnames*)
(setq whole (c1make-var (cadr vl) ss is ts))
(push whole *dm-vars*)
(push whole *vars*)
(setq vl (cddr vl))
)
(when (and (listp vl) (eq (car vl) '&environment))
(push (cadr vl) *vnames*)
(setq env (c1make-var (cadr vl) ss is ts))
(push env *dm-vars*)
(push env *vars*)
(setq vl (cddr vl)))
(multiple-value-setq (vl ppn) (c1dm-vl vl ss is ts))
(check-vdecl *vnames* ts is)
(setq body (c1decl-body other-decls body))
(add-info *dm-info* (cadr body))
(dolist* (v *dm-vars*) (check-vref v))
(list doc ppn whole env vl body)
)
(defun c1dm-vl (vl ss is ts)
(do ((optionalp nil) (restp nil) (keyp nil) (allow-other-keys-p nil)
(auxp nil)
(requireds nil) (optionals nil) (rest nil) (key-flag nil)
(keywords nil) (auxs nil) (allow-other-keys nil)
(n 0) (ppn nil)
)
((not (consp vl))
(when vl
(when restp (dm-bad-key '&rest))
(setq rest (c1dm-v vl ss is ts)))
(values (list (reverse requireds) (reverse optionals) rest key-flag
(reverse keywords) allow-other-keys (reverse auxs))
ppn)
)
(let ((v (car vl)))
(declare (object v))
(cond
((eq v '&optional)
(when optionalp (dm-bad-key '&optional))
(setq optionalp t)
(pop vl))
((or (eq v '&rest) (eq v '&body))
(when restp (dm-bad-key v))
(setq rest (c1dm-v (cadr vl) ss is ts))
(setq restp t optionalp t)
(setq vl (cddr vl))
(when (eq v '&body) (setq ppn n)))
((eq v '&key)
(when keyp (dm-bad-key '&key))
(setq keyp t restp t optionalp t key-flag t)
(pop vl))
((eq v '&allow-other-keys)
(when (or (not keyp) allow-other-keys-p)
(dm-bad-key '&allow-other-keys))
(setq allow-other-keys-p t allow-other-keys t)
(pop vl))
((eq v '&aux)
(when auxp (dm-bad-key '&aux))
(setq auxp t allow-other-keys-p t keyp t restp t optionalp t)
(pop vl))
(auxp
(let (x init)
(cond ((symbolp v) (setq x v init (c1nil)))
(t (setq x (car v))
(if (endp (cdr v))
(setq init (c1nil))
(setq init (c1expr* (cadr v) *dm-info*)))))
(push (list (c1dm-v x ss is ts) init) auxs))
(pop vl))
(keyp
(let (x k init (sv nil))
(cond ((symbolp v)
(setq x v k (intern (string v) 'keyword) init (c1nil)))
(t (if (symbolp (car v))
(setq x (car v)
k (intern (string (car v)) 'keyword))
(setq x (cadar v) k (caar v)))
(cond ((endp (cdr v)) (setq init (c1nil)))
(t (setq init (c1expr* (cadr v) *dm-info*))
(unless (endp (cddr v))
(setq sv (caddr v)))))))
(push (list k (c1dm-v x ss is ts) init
(if sv (c1dm-v sv ss is ts) nil))
keywords)
)
(pop vl))
(optionalp
(let (x init (sv nil))
(cond ((symbolp v) (setq x v init (c1nil)))
(t (setq x (car v))
(cond ((endp (cdr v))
(setq init (c1nil)))
(t (setq init (c1expr* (cadr v) *dm-info*))
(unless (endp (cddr v))
(setq sv (caddr v)))))))
(push (list (c1dm-v x ss is ts) init
(if sv (c1dm-v sv ss is ts) nil))
optionals))
(pop vl)
(incf n)
)
(t (push (c1dm-v v ss is ts) requireds)
(pop vl)
(incf n))
)))
)
(defun c1dm-v (v ss is ts)
(cond ((symbolp v)
(push v *vnames*)
(setq v (c1make-var v ss is ts))
(push v *vars*)
(push v *dm-vars*)
v)
(t (c1dm-vl v ss is ts))))
(defun c1dm-bad-key (key)
(cmperr "Defmacro-lambda-list contains illegal use of ~s." key))
(defun c2dm (whole env vl body
&aux (cvar (next-cvar)))
(when (or *safe-compile* *compiler-check-args*)
(wt-nl "check_arg(2);"))
(cond (whole (setf (var-ref whole) (vs-push)))
(t (vs-push)))
(cond (env (setf (var-ref env) (vs-push)))
(t (vs-push)))
(c2dm-reserve-vl vl)
(wt-nl "vs_top=sup;")
(when whole (c2bind whole))
(when env (c2bind env))
(wt-nl "{object V" cvar "=base[0]->c.c_cdr;")
(c2dm-bind-vl vl cvar)
(wt "}")
(c2expr body)
)
(defun c2dm-reserve-vl (vl)
(dolist** (var (car vl)) (c2dm-reserve-v var))
(dolist** (opt (cadr vl))
(c2dm-reserve-v (car opt))
(when (caddr opt) (c2dm-reserve-v (caddr opt))))
(when (caddr vl) (c2dm-reserve-v (caddr vl)))
(dolist** (kwd (car (cddddr vl)))
(c2dm-reserve-v (cadr kwd))
(when (cadddr kwd) (c2dm-reserve-v (cadddr kwd))))
(dolist** (aux (caddr (cddddr vl)))
(c2dm-reserve-v (car aux)))
)
(defun c2dm-reserve-v (v)
(if (consp v)
(c2dm-reserve-vl v)
(setf (var-ref v) (vs-push))))
(defun c2dm-bind-vl (vl cvar
&aux
(requireds (car vl)) (optionals (cadr vl))
(rest (caddr vl)) (key-flag (cadddr vl))
(keywords (car (cddddr vl)))
(allow-other-keys (cadr (cddddr vl)))
(auxs (caddr (cddddr vl)))
)
(declare (object requireds optionals rest key-flag keywords allow-other-keys
auxs))
(do ((reqs requireds (cdr reqs)))
((endp reqs))
(declare (object reqs))
(when (or *safe-compile* *compiler-check-args*)
(wt-nl "if(endp(V" cvar "))invalid_macro_call();"))
(c2dm-bind-loc (car reqs) `(car ,cvar))
(when (or (cdr reqs) optionals rest key-flag
*safe-compile* *compiler-check-args*)
(wt-nl "V" cvar "=V" cvar "->c.c_cdr;")))
(do ((opts optionals (cdr opts)))
((endp opts))
(declare (object opts))
(let ((opt (car opts)))
(declare (object opt))
(wt-nl "if(endp(V" cvar ")){")
(let ((*clink* *clink*)
(*unwind-exit* *unwind-exit*)
(*ccb-vs* *ccb-vs*))
(c2dm-bind-init (car opt) (cadr opt))
(when (caddr opt) (c2dm-bind-loc (caddr opt) nil))
)
(wt-nl "} else {")
(c2dm-bind-loc (car opt) `(car ,cvar))
(when (caddr opt) (c2dm-bind-loc (caddr opt) t)))
(when (or (cdr opts) rest key-flag
*safe-compile* *compiler-check-args*)
(wt-nl "V" cvar "=V" cvar "->c.c_cdr;"))
(wt "}"))
(when rest (c2dm-bind-loc rest `(cvar ,cvar)))
(dolist** (kwd keywords)
(let ((cvar1 (next-cvar)))
(wt-nl
"{object V" cvar1 "=getf(V" cvar ",VV[" (add-symbol (car kwd))
"],OBJNULL);")
(wt-nl "if(V" cvar1 "==OBJNULL){")
(let ((*clink* *clink*)
(*unwind-exit* *unwind-exit*)
(*ccb-vs* *ccb-vs*))
(c2dm-bind-init (cadr kwd) (caddr kwd))
(when (cadddr kwd) (c2dm-bind-loc (cadddr kwd) nil))
(wt-nl "} else {"))
(c2dm-bind-loc (cadr kwd) `(cvar ,cvar1))
(when (cadddr kwd) (c2dm-bind-loc (cadddr kwd) t))
(wt "}}")))
(when (and (or *safe-compile* *compiler-check-args*)
(null rest)
(null key-flag))
(wt-nl "if(!endp(V" cvar "))invalid_macro_call();"))
(when (and (or *safe-compile* *compiler-check-args*)
key-flag
(not allow-other-keys))
(wt-nl "check_other_key(V" cvar "," (length keywords))
(dolist** (kwd keywords)
(wt ",VV[" (add-symbol (car kwd)) "]"))
(wt ");"))
(dolist** (aux auxs)
(c2dm-bind-init (car aux) (cadr aux)))
)
(defun c2dm-bind-loc (v loc)
(if (consp v)
(let ((cvar (next-cvar)))
(wt-nl "{object V" cvar "= " loc ";")
(c2dm-bind-vl v cvar)
(wt "}"))
(c2bind-loc v loc)))
(defun c2dm-bind-init (v init)
(if (consp v)
(let* ((*vs* *vs*) (*inline-blocks* 0)
(cvar (next-cvar))
(loc (car (inline-args (list init) '(t)))))
(wt-nl "{object V" cvar "= " loc ";")
(c2dm-bind-vl v cvar)
(wt "}")
(close-inline-blocks))
(c2bind-init v init)))